home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 003 / pcmap.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1984-04-24  |  8.9 KB  |  236 lines
  1. 1  '*********************************************************************
  2. 2  '*   PC-MAP.  This program recreates a PC-File database into a new   *
  3. 3  '*            Format. Fields may be added or deleted, renamed,       *
  4. 4  '*            rearranged, and lengthened or shortened. Output is a   *
  5. 5  '*            Data file and Header file.  After using PC-File to     *
  6. 6  '*            sort the file (thus creating a new index), the new     *
  7. 7  '*            database is ready to go.                               *
  8. 8  '*            (1982) by F. Neil Lamka.                               *
  9. 9  '*********************************************************************
  10. 10  DEFINT A-Z:COMMON F$,DL,XL,NR
  11. 20  CLS:RC=80
  12. 25  ERCOUNT = 0
  13. 30  FALSE=0:TRUE=1
  14. 40  MC=RC\2:F9=RC\2+2
  15. 50  SCREEN 0,0:COLOR 7,0
  16. 60  WIDTH RC:KEY OFF
  17. 70  DIM OFM$(42),OFL(42) 'set up arrays for field names and lengths
  18. 80  DIM NFM$(42),NFL(42) 'set up arrays for new data base
  19. 90  CLS:LOCATE 10,MC-9:PRINT"PC-MAP Version 1.4";
  20. 95  LOCATE 12,MC-17:PRINT"A PC-FILE Data Base Conversion Aid";
  21. 100  LOCATE 14,MC-11:PRINT"(1982) F. Neil Lamka"
  22. 110  DR$="Which drive (ABCD) contains the origional data base? "
  23. 120  CL = 0
  24. 130  UC=1:GOSUB 20000
  25. 140  IF DR$<"A" OR DR$>"D" GOTO 110
  26. 150  OF$ = DR$+":"   'set file name for old data base
  27. 155  TF$=OF$
  28. 160  DR$="Which drive (ABCD) will contain the new data base? "
  29. 170  CL = -3 'set value for message color (15-3)
  30. 180  UC=1:GOSUB 20000
  31. 190  CL = 0 'reset line color value
  32. 200  IF DR$<"A" OR DR$>"D" GOTO 160
  33. 210  NF$ = DR$+ ":"  'set file name for new data base
  34. 220  ON ERROR GOTO 250
  35. 230  CLS:LOCATE 5,1:PRINT"Choose one of these files to convert:"
  36. 240  FILES OF$+"*.HDR":GOSUB 30000:ON ERROR GOTO 0:GOTO 260
  37. 250  RESUME 260
  38. 260  DR$="Which file:":UC=1:GOSUB 20000
  39. 270  IF DR$="" THEN 260 ELSE OF$ = TF$ + DR$ 'set file name to be used
  40. 280  ON ERROR GOTO 330
  41. 290  VL$=".HDR":FILES OF$+VL$ 'see if the hdr file exists
  42. 300  VL$=".DTA":FILES OF$+VL$ 'see if the data file exists
  43. 310  ON ERROR GOTO 0
  44. 320  CLS:GOTO 360  'go get new file name
  45. 330  RESUME 340
  46. 340  ON ERROR GOTO 0:DR$=OF$+VL$+" does not exist...please respecify: "
  47. 341  CL=-4:UC=1:SOUND 500,9:GOSUB 20000:CL=0
  48. 342  IF DR$="" THEN 260 ELSE OF$=TF$+DR$
  49. 350  GOTO 280
  50. 360  TF$=NF$
  51. 365  DR$="Enter name for new data base: ":CL= -3:UC=1:GOSUB 20000
  52. 370  IF DR$="" THEN 360 ELSE NF$=NF$+DR$ 'set new data base name
  53. 375  IF NF$=OF$ THEN DR$="INVALID NAME - SAME AS THE FIRST ONE - RESPECIFY ":NF$=TF$:UC=1:CL=-4:SOUND 500,4:GOSUB 20000:CL=0:GOTO 370
  54. 380  ON ERROR GOTO 440
  55. 400  VL$=".HDR":FILES NF$+VL$ 'see if a hdr file exists
  56. 410  CLS:DR$=NF$+VL$+" already exists...respecify or hit ENTER to reuse: "
  57. 415  ON ERROR GOTO 0
  58. 420  UC=1:CL=-4:SOUND 500,4:GOSUB 20000:CL=0
  59. 430  IF DR$="" THEN KILL NF$+VL$:GOTO 450 ELSE NF$=TF$+DR$:GOTO 380
  60. 440  RESUME 450 'if we get here then the files did not exist
  61. 450  ON ERROR GOTO 0
  62. 452  ON ERROR GOTO 462:VL$=".DTA":FILES NF$+VL$
  63. 454  CLS:DR$=NF$+VL$+" already exists...respecify or hit ENTER to reuse: "
  64. 456  ON ERROR GOTO 0
  65. 458  UC=1:CL=-3:SOUND 500,9:GOSUB 20000:CL=0
  66. 460  IF DR$="" THEN KILL NF$+VL$:GOTO 464 ELSE NF$=TF$+DR$:GOTO 380
  67. 462  RESUME 464 'files did not exist if we are here
  68. 464  ON ERROR GOTO 0
  69. 500  REM All files have been verified...now start the work
  70. 510  ODL=0:ODF=0 'set record length and number of entries in old db
  71. 520  NDL=0:NDF=0 'set record length and number of entries in new db
  72. 530  CLS
  73. 540  PRINT"Reading origional data base records ";MID$(OF$,3)
  74. 550  OPEN"i",#1,OF$+".HDR"  'open old header file
  75. 560  WHILE NOT EOF(1)       'read old data base header description
  76. 570  INPUT#1,TS$:ODF =ODF + 1:OFM$(ODF) = TS$ 'read label
  77. 580  INPUT#1,OFL(ODF):ODL = ODL + OFL(ODF)
  78. 590  WEND 'end of the loop
  79. 595  CLOSE#1 'done with the old header file
  80. 600  CLS:LOCATE 2,1:PRINT "Origional Data Base Fields";
  81. 602  LOCATE 3,1:PRINT OF$+".HDR";
  82. 605  LC=4:MAXLEN = 0
  83. 610  LOCATE LC,1
  84. 620  FOR I = 1 TO ODF
  85. 630  IF OFL(I) > MAXLEN THEN MAXLEN=OFL(I)
  86. 635  LOCATE LC+I,1:PRINT OFM$(I);:PRINT,USING" ###";OFL(I)
  87. 640  NEXT I
  88. 650  IF MAXLEN+3+2 <= 40 THEN NEXTFIELD=40 ELSE NEXTFIELD=0
  89. 700  LOCATE 1,1:COLOR 12,0:SOUND 800,4:PRINT"Enter values for the new headers";
  90. 703  LOCATE 2,NEXTFIELD:COLOR 15,0:PRINT"New Data Base fields";
  91. 705  LOCATE 3,NEXTFIELD:PRINT NF$+".HDR";
  92. 710  ATLINE = 1:NDF=0:NEWEND = FALSE
  93. 715  CURMAX = 12:COLOR 15,0
  94. 720  WHILE NEWEND = FALSE
  95. 725  IF ATLINE+LC >24 THEN GOSUB 10000:ATLINE = 1
  96. 730  LOCATE ATLINE+LC,NEXTFIELD
  97. 740  LINE INPUT;"";TS$:IF TS$="" THEN NEWEND=TRUE:GOTO 750 ELSE NDF=NDF+1:NFM$(NDF) = TS$
  98. 741  IF LEN(NFM$(NDF)) > 12 THEN NFM$(NDF)=LEFT$(NFM$(NDF),12):LOCATE ATLINE+LC,NEXTFIELD:PRINT NFM$(NDF)+SPACE$(LEN(TS$)-12);
  99. 745  ATLINE = ATLINE + 1
  100. 750  WEND:COLOR 7,0
  101. 752  DR$="Is this HDR information correct (Y or N)? ":UC=1:CL=0:GOSUB 20000
  102. 753  IF DR$="" THEN 752 ELSE IF DR$ = "N" THEN GOSUB 40000:GOTO 710 ELSE IF DR$ <> "Y" THEN 752
  103. 759  NDL=0:LOCATE 1,1:PRINT"                                 "
  104. 760  LOCATE 1,40:COLOR 12,0:PRINT"Enter the width of each field    ";:COLOR 4,0
  105. 765  SOUND 800,5
  106. 770  FOR I = 1 TO NDF
  107. 780  LOCATE LC+I,NEXTFIELD+CURMAX+1
  108. 790  LINE INPUT;"";TS$:NFL(I)=VAL(TS$):NDL=NDL+NFL(I)
  109. 792  IF NFL(I) = 0 THEN LOCATE 25,1:PRINT"Spceified field length is not valid..Please reenter";:SOUND 500,9:GOTO 780
  110. 795  LOCATE LC+I,NEXTFIELD+CURMAX+1:PRINT,USING"###";NFL(I)
  111. 796  LOCATE 25,1:PRINT"                                                    ";
  112. 800  NEXT I
  113. 802  DR$="Is this field width information correct (Y or N)? ":UC=1:CL=0:GOSUB 20000
  114. 803  IF DR$="" THEN 802 ELSE IF DR$ = "N" THEN GOSUB 50000:GOTO 759 ELSE IF DR$ <> "Y" THEN 802
  115. 810  COLOR 7,0
  116. 900  CLS 'now that the data fields have been defined...we need relationships
  117. 910  LOCATE 1,1:PRINT"Define field relationship values";
  118. 920  LOCATE 2,1:PRINT"For each field in the new data base indicate the";
  119. 930  LOCATE 3,1:PRINT"corresponding old data base field number or 0";
  120. 940  LOCATE 4,1
  121. 950  FOR I = 1 TO NDF 'output new data fields
  122. 960  LOCATE 4+I,1:PRINT NFM$(I);
  123. 980  NEXT I
  124. 990  FOR I = 1 TO ODF 'output old data base fields
  125. 1000  LOCATE 4+I,50:PRINT OFM$(I)
  126. 1005  LOCATE 4+I,30:PRINT,USING"###";I;
  127. 1010  NEXT I
  128. 1015  DIM FR(42) 'set the size of the relationship matrix to the # of data flds
  129. 1020  FOR I = 1 TO NDF 'get field relationship value
  130. 1030  LOCATE 4+I,25
  131. 1040  LINE INPUT;"";TS$:IF TS$ = "" THEN 1030
  132. 1050  IF (VAL(TS$) > ODF) OR (VAL(TS$) < 0) THEN LOCATE 25,1:PRINT"Invalid field relationship specified";:SOUND 500,9:GOTO 1030
  133. 1060  LOCATE 25,1:PRINT"                                    ";
  134. 1070  FR(I) = VAL(TS$) 'set the field relationship matrix value
  135. 1080  NEXT I
  136. 1082  DR$="Are these field relationships correct (Y or N)? ":CL=0:UC=1:GOSUB 20000
  137. 1084  IF DR$="" THEN 1082 ELSE IF DR$="N" THEN GOSUB 60000:GOTO 1020 ELSE IF DR$ <> "Y" THEN 1082
  138. 1100  CLS 'now we have all we need to remap the data base
  139. 1110  DIM OFILE$(42),NFILE$(42) 'set up to map the data base
  140. 1120  CLS:PRINT"Writing new HDR file ";:COLOR 12,0
  141. 1130  PRINT NF$+".HDR":COLOR 7,0
  142. 1140  OPEN"o",#1,NF$+".HDR"
  143. 1150  FOR I = 1 TO NDF 'loop until end of header info
  144. 1160  PRINT#1,NFM$(I) 'write out the header name
  145. 1170  PRINT#1,NFL(I)  'write out the field lenght
  146. 1180  NEXT I
  147. 1190  CLOSE#1         'close the new header file
  148. 1200  PRINT"New Header file created"
  149. 1210  REM open the DTA data sets for processing
  150. 1220  OPEN"r",#2,OF$+".DTA",ODL+1
  151. 1230  FIELD#2,ODL AS ODF$          'set up a field for direct read
  152. 1240  OPEN"r",#3,NF$+".DTA",NDL+1
  153. 1250  FIELD#3,NDL AS NDF$          'this will be the outputfield
  154. 1260  X = 1 'set initial record number
  155. 1265  FEND = FALSE
  156. 1270  WHILE FEND = FALSE  'read until \ record found in data base
  157. 1280  GET#2,X  'read record from the old data base
  158. 1290  IF LEFT$(ODF$,1) = "\" THEN FEND=TRUE:DR$="\":GOTO 1400
  159. 1295  'IF LEFT($(ODF$,2)="//" THEN GOTO 1408  check for deleted record
  160. 1300  CPOS = 1 'map old data record to array
  161. 1310  FOR I = 1 TO ODF
  162. 1320  OFILE$(I)=MID$(ODF$,CPOS,OFL(I)):CPOS=CPOS+OFL(I)
  163. 1330  NEXT I
  164. 1340  FOR J = 1 TO NDF
  165. 1350  IF FR(J)=0 THEN NFILE$(J)=SPACE$(NFL(J)):GOTO 1372
  166. 1362  IF NFL(J)<=OFL(FR(J)) THEN NFILE$(J)=LEFT$(OFILE$(FR(J)),NFL(J)):GOTO 1372
  167. 1364  IF NFL(J)>OFL(FR(J)) THEN NFILE$(J)=OFILE$(FR(J))+SPACE$(NFL(J)-OFL(FR(J)))
  168. 1372  NEXT J
  169. 1375  DR$=""
  170. 1376  FOR K=1 TO NDF:DR$=DR$+LEFT$(NFILE$(K),NFL(K)):NEXT K
  171. 1400  LSET NDF$=DR$:PUT#3,X       'write the new record
  172. 1401  CLS:LOCATE 1,1:PRINT"Processing record number(",X,")";
  173. 1402  LOCATE 2,1:PRINT"New File Record";
  174. 1403  LOCATE 2,40:PRINT"Old File Record";
  175. 1406  FOR K = 1 TO NDF:LOCATE 3+K,1:PRINT NFILE$(K);:NEXT K
  176. 1407  FOR K = 1 TO ODF:LOCATE 3+K,40:PRINT OFILE$(K);:NEXT K
  177. 1408  X=X+1
  178. 1410  WEND
  179. 1420  CLOSE#2:CLOSE#3
  180. 1500  CLS 'output final file stats
  181. 1510  LOCATE 8,28:PRINT"File conversion complete";
  182. 1520  LOCATE 9,28:PRINT"Data Base Statistics are";
  183. 1530  LOCATE 11,1 :PRINT"Origional Data Base = ";:LOCATE 11,30:PRINT OF$;
  184. 1550  LOCATE 12,1:PRINT"Origional number of fields = ";:LOCATE 12,30:PRINT ODF;
  185. 1552  LOCATE 13,1:PRINT"Record Length = ";:LOCATE 13,30:PRINT ODL;
  186. 1555  COLOR 15,0
  187. 1560  LOCATE 15,1:PRINT"New Data Base = ";:LOCATE 15,30:PRINT NF$;
  188. 1570  LOCATE 16,1:PRINT"New number of fields = ";:LOCATE 16,30:PRINT NDF;
  189. 1580  LOCATE 17,1:PRINT"New Total Record Length = ";:LOCATE 17,30:PRINT NDL;
  190. 1590  LOCATE 20,1:PRINT"Number of Data Records Read = ",X-1;
  191. 1600  COLOR 7,0
  192. 1610  GOSUB 60990 'go wait for input key to continue
  193. 1615  CLS:PRINT"Your new database is built."
  194. 1620  PRINT:PRINT"You must remember to sort the database"
  195. 1625  PRINT:PRINT"the first time you use it."
  196. 1640  END
  197. 10000  FOR LP = LC+1 TO 24
  198. 10010  LOCATE LP,NEXTFIELD:PRINT SPC(79-NEXTFIELD)
  199. 10020  NEXT LP
  200. 10030  RETURN
  201. 20000  GOSUB 20110
  202. 20010  SOUND 200,9
  203. 20020  LOCATE 25,1:COLOR 15+CL,0
  204. 20030  PRINT DR$;:COLOR 7,0
  205. 20040  LINE INPUT;"";DR$
  206. 20050  IF LEN(DR$)<1 GOTO 20110
  207. 20060  IF UC=0 GOTO 20110
  208. 20070  FOR NN = 1 TO LEN(DR$) 'fold to upper case
  209. 20080  X=ASC(MID$(DR$,NN,1))
  210. 20090  IF X>=97 AND X <= 122 THEN MID$(DR$,NN,1)=CHR$(X-32)
  211. 20100  NEXT:UC = 0
  212. 20110  LOCATE 25,1:PRINT SPACE$(RC-1);:LOCATE 25,1:RETURN
  213. 30000  FOR R = 6 TO 24
  214. 30010  FOR C = 9 TO RC-2 STEP 13
  215. 30020  LOCATE R,C:PRINT"     ";
  216. 30030  NEXT C:NEXT R
  217. 30040  RETURN
  218. 40000  FOR I = 1 TO NDF 'routine called if new field names incorrect
  219. 40010  NFM$(I) = ""
  220. 40020  LOCATE LC+I,NEXTFIELD:PRINT SPC(RC-NEXTFIELD);
  221. 40030  NEXT I
  222. 40040  RETURN
  223. 50000  FOR I = 1 TO NDF 'routine to be called if new field width incorrect
  224. 50020  NFL(I)=0
  225. 50025  LOCATE LC+I,NEXTFIELD+CURMAX+1:PRINT,USING"###";NFL(I);
  226. 50030  NEXT I
  227. 50040  RETURN
  228. 60000  FOR I = 1 TO NDF 'routine to be used if relationship vals incorrect
  229. 60010  LOCATE 4+I,25:PRINT SPC(5)
  230. 60020  FR(I) = 0
  231. 60030  NEXT I
  232. 60040  RETURN
  233. 60990  REM 'Wait for input key subroutine
  234. 60991  LOCATE 25,1:PRINT"Hit any key to continue";
  235. 60992  K$=INKEY$:IF K$="" THEN 60992 ELSE RETURN
  236.